home *** CD-ROM | disk | FTP | other *** search
/ Win Platinum / Win Platinum.iso / desktop / wallpeep / wallmodl.bas < prev    next >
Encoding:
BASIC Source File  |  1992-11-24  |  6.9 KB  |  258 lines
  1. Declare Function GetProfileString% Lib "Kernel" (ByVal lpAppName$, ByVal lpKeyName$, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%)
  2. Global Const WM_USER = &H400
  3. Global Const LB_RESETCONTENT = WM_USER + 5
  4. Global Const PIXEL = 3
  5.  
  6. Sub AddNames (I As Integer)
  7.     Form1.File2.Path = Form1.Dir2.List(I)
  8.     For J = 0 To Form1.File2.ListCount - 1
  9.         Form1.List1.AddItem Form1.File2.List(J) + Chr$(9) + Chr$(9) + Format$(Dirs)
  10.     Next J
  11. End Sub
  12.  
  13. Sub CallUpPBrush (DName$, FName$)
  14. If Right$(DName$, 1) <> "\" Then DName$ = DName$ + "\"
  15. OldMousePointer = Screen.MousePointer
  16. Screen.MousePointer = 11
  17. If (Form2.DestinationPic.ScaleWidth <> Form1.Picture1.ScaleWidth) Or (Form2.DestinationPic.ScaleHeight <> Form1.Picture1.ScaleHeight) Then
  18.    Resp% = MsgBox("Do you want to start Paintbrush with the scaled image in the clipboard ready for pasting to create a new file?", 32 + 4)
  19.    If Resp% = 6 Then
  20.       Clipboard.Clear
  21.       Clipboard.SetData Form2.DestinationPic.Image
  22.       T% = Shell("pbrush", 1)
  23.       Screen.MousePointer = OldMousePointer
  24.       Exit Sub
  25.    End If
  26. End If
  27. If (Right$(FName$, 4) <> ".bmp") Then
  28.    Resp% = MsgBox(UCase$(FName$) + " is not a .BMP file and can't be directly changed in Paintbrush." + Chr$(13) + Chr$(13) + "Do you want to start Paintbrush with the image in the clipboard ready for pasting to create a new file?", 32 + 4)
  29.    If Resp% = 6 Then
  30.       Clipboard.Clear
  31.       Clipboard.SetData Form1.Picture1.Image
  32.       T% = Shell("pbrush", 1)
  33.    End If
  34.    'MsgBox "Sorry!  Not a BMP file."
  35. Else
  36.    T% = Shell("pbrush " + DName$ + FName$, 1)
  37. End If
  38. Screen.MousePointer = OldMousePointer
  39.  
  40. End Sub
  41.  
  42. Sub ClearListBox (Ctrl As Control)
  43.   hWndOld% = GetFocus()
  44.   tempE% = Ctrl.Enabled
  45.   tempV% = Ctrl.Visible
  46.   Ctrl.Enabled = True
  47.   Ctrl.Visible = True
  48.  
  49.   Ctrl.SetFocus
  50.   x = SendMessage(GetFocus(), LB_RESETCONTENT, 0, 0&)
  51.   Ctrl.Enabled = tempE%
  52.   Ctrl.Visible = tempV%
  53.   Suc% = PutFocus(hWndOld%)
  54. End Sub
  55.  
  56. Sub File1DClick ()
  57. DName$ = Form1.File1.Path
  58. Call CallUpPBrush(DName$, (Form1.File1.FileName))
  59. End Sub
  60.  
  61. Sub FillList ()
  62. Form1.Command2.Visible = False
  63. Form1.Label1.Visible = True
  64. ClearListBox Form1.List1
  65.  
  66. On Error Resume Next
  67. Form1.Dir2.Path = Form1.Drive1.Drive + "\"
  68. If Err <> 0 Then
  69.    On Error Resume Next
  70.    Form1.Drive1.Drive = SavedDrive$
  71.    Form1.Dir2.Path = SavedDrive$ + "\"
  72. End If
  73. On Error GoTo 0
  74. SavedDrive$ = Form1.Drive1.Drive
  75. Dirs = 1
  76. DirName(Dirs) = Form1.Dir2.Path
  77. AddNames (-1)    'was 1
  78. CheckingDir = 0
  79. While CheckingDir < Dirs
  80.    If CheckingDir Mod 10 = 0 Then
  81.       Form1.Label1.Caption = Format$(CheckingDir) + " / " + Format$(Dirs)
  82.       T% = DoEvents()
  83.    End If
  84.    CheckingDir = CheckingDir + 1
  85.    On Error Resume Next
  86.    Form1.Dir2.Path = DirName(CheckingDir)
  87.    On Error GoTo 0
  88.    For I = 0 To Form1.Dir2.ListCount - 1
  89.       Dirs = Dirs + 1
  90.       DirName(Dirs) = Form1.Dir2.List(I)
  91.       AddNames (I)
  92.    Next I
  93.  
  94. Wend
  95.  
  96.  
  97. Form1.Label1.Caption = ""
  98. Form1.Label1.Visible = False
  99. Form1.Command2.Enabled = False
  100. Form1.Command2.Visible = True
  101. If Form1.List1.ListCount > 0 Then Form1.List1.ListIndex = 0
  102.  
  103. End Sub
  104.  
  105. Function FindItem (Lst As Control, a$) As Integer
  106. Dim U As Integer
  107. Dim L As Integer
  108. Dim I As Integer
  109. U = Lst.ListCount
  110. L = 0
  111. I = 0
  112. If U = 0 Then
  113.    FindItem = -1
  114.    Exit Function
  115. End If
  116. Do
  117.    If U < L Then
  118.       'Lst.ListIndex = I + 1'set .ListIndex to nearest match
  119.       FindItem = -1
  120.       Exit Function
  121.    End If
  122.  
  123.    I = (L + U) / 2
  124.    If a$ = Lst.List(I) Then
  125.       Lst.ListIndex = I  'Found. Set ".ListIndex" accordingly
  126.       FindItem = I
  127.       Exit Function
  128.    Else
  129.       If a$ > Lst.List(I) Then
  130.          L = I + 1
  131.       Else
  132.          U = I - 1
  133.       End If
  134.    End If
  135. Loop
  136. End Function
  137.  
  138. Sub GetBackgroundColor ()
  139.    lpDefault$ = "0 0 0" + String$(256, " ")
  140.    lpRS$ = "0 0 0" + String$(256, " ")
  141.    T% = GetProfileString%("colors", "Background", lpDefault$, lpRS$, 256)
  142.    SP1Pos = InStr(lpRS$, " ")
  143.    R$ = Left$(lpRS$, SP1Pos - 1)
  144.    GB$ = Mid$(lpRS$, SP1Pos + 1, 255)
  145.    SP1Pos = InStr(GB$, " ")
  146.    G$ = Left$(GB$, SP1Pos - 1)
  147.    B$ = Mid$(GB$, SP1Pos + 1, 255)
  148.    bgCol& = RGB(Val(R$), Val(G$), Val(B$))
  149.    Form2.BackColor = bgCol&
  150.  
  151. End Sub
  152.  
  153. Sub GetNameAndDir (T$, FName$, DName$)
  154. FName$ = Left$(T$, InStr(T$, Chr$(9)) - 1)
  155. DName$ = DirName(Val(Mid$(T$, InStr(T$, Chr$(9)) + 2, 255)))
  156. 'If Right$(DName$, 1) <> "\" Then DName$ = DName$ + "\"
  157. End Sub
  158.  
  159. Sub List1DClick ()
  160. Call GetNameAndDir((Form1.List1.List(Form1.List1.ListIndex)), FName$, DName$)
  161. Call CallUpPBrush(DName$, FName$)
  162. End Sub
  163.  
  164. Sub ShowPicture (D$, F$)
  165. Form1.Picture1.AutoRedraw = True
  166. Form1.Picture1.Cls
  167. Form2.DestinationPic.AutoRedraw = True
  168. Form2.DestinationPic.Cls
  169. On Error Resume Next
  170. If Right$(D$, 1) = "\" Then
  171.    Form1.Picture1.Picture = LoadPicture(D$ + F$)
  172. Else
  173.    Form1.Picture1.Picture = LoadPicture(D$ + "\" + F$)
  174. End If
  175. If Right$(F$, 4) = ".wmf" Then
  176.    Metafile = True
  177. Else
  178.    Metafile = False
  179. End If
  180.  
  181. If Err <> 0 Then MsgBox "Can't load that picture."
  182. On Error GoTo 0
  183. Form2.DestinationPic.AutoSize = True
  184. Form2.DestinationPic.Picture = Form1.Picture1.Picture
  185. Form2.DestinationPic.AutoSize = False
  186. End Sub
  187.  
  188. Sub WallPaper ()
  189.  
  190. OldMousePointer = Screen.MousePointer
  191. Screen.MousePointer = 11
  192.  
  193. 'Assign information of the destination bitmap. Note that BitBlt() requires coordinates in pixels.
  194.  
  195. Form2.DestinationPic.ScaleMode = PIXEL
  196. Form2.ScaleMode = PIXEL
  197. nWidth% = Form2.DestinationPic.ScaleWidth
  198. nHeight% = Form2.DestinationPic.ScaleHeight
  199.  
  200. 'Assign information of the source bitmap.
  201. hSrcDC% = Form2.DestinationPic.hDC
  202. XSrc% = 0: YSrc% = 0
  203.  
  204. 'Assign the SRCCOPY constant to the raster operation.
  205. dwRop& = &HCC0020
  206. HorzCenter% = Form2.ScaleWidth / 2
  207. VertCenter% = Form2.ScaleHeight / 2
  208. If Form1.TileChecked.Value = 0 Then
  209.    LBWidth% = HorzCenter% - nWidth% / 2
  210.    LBHeight% = VertCenter% - nHeight% / 2
  211.    UBWidth% = HorzCenter% + nWidth% / 2 - 1
  212.    UBHeight% = VertCenter% + nHeight% / 2 - 1
  213.    
  214.    Form2.ForeColor = Form2.BackColor
  215.  
  216.    hDestDC% = Form2.hDC
  217.    Form2.FillColor = Form2.BackColor
  218.    Suc% = PatBlt(hDestDC%, 0, 0, Form2.ScaleWidth, Form2.ScaleHeight, &HF00021)
  219.    Form2.DestinationPic.Left = LBWidth%
  220.    Form2.DestinationPic.Top = LBHeight%
  221. Else
  222.    LBWidth% = 0
  223.    LBHeight% = 0
  224.    UBWidth% = Form2.ScaleWidth
  225.    UBHeight% = Form2.ScaleHeight
  226. 'End If
  227.  
  228. x% = LBWidth%
  229. Y% = LBHeight%
  230. For I% = 1 To 1
  231.    If I% = 1 Then
  232.       Form2.AutoRedraw = -1
  233.       hDestDC% = Form2.hDC
  234.    Else
  235.       Form2.AutoRedraw = -1
  236.       hDestDC% = Form2.hDC
  237.    End If
  238.    If (nHeight% > 0) And (nWidth% > 0) Then
  239.       While Y% < UBHeight%
  240.          While x% < UBWidth%
  241.          Suc% = BitBlt(hDestDC%, x%, Y%, nWidth%, nHeight%, hSrcDC%, XSrc%, YSrc%, dwRop&)
  242.          x% = x% + nWidth%
  243.          Wend
  244.          x% = LBWidth%
  245.          Y% = Y% + nHeight%
  246.       Wend
  247.    Else
  248.       Form2.Cls
  249.       Form2.Print "?!"
  250.    End If
  251. Next I%
  252. End If
  253.  
  254. Form2.Refresh
  255. Screen.MousePointer = OldMousePointer
  256. End Sub
  257.  
  258.